Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH10/SRC/OBJEXTR.CLS

Text File | 1996-05-04 | 8.9 KB | 305 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ObjExtrusion"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

Private NumCurvePts As Integer
Private NumPathPts As Integer

Private CurvePoints() As Point3D
Private PathPoints() As Point3D

Private pline As ObjPolyline    ' Display polyline.
' ************************************************
' Add a point to the path.
' ************************************************
Public Sub AddPathPoint(x As Single, y As Single, z As Single)
    NumPathPts = NumPathPts + 1
    ReDim Preserve PathPoints(1 To NumPathPts)
    PathPoints(NumPathPts).coord(1) = x
    PathPoints(NumPathPts).coord(2) = y
    PathPoints(NumPathPts).coord(3) = z
    PathPoints(NumPathPts).coord(4) = 1
End Sub

' ************************************************
' Add a point to the curve.
' ************************************************
Public Sub AddCurvePoint(x As Single, y As Single, z As Single)
    NumCurvePts = NumCurvePts + 1
    ReDim Preserve CurvePoints(1 To NumCurvePts)
    CurvePoints(NumCurvePts).coord(1) = x
    CurvePoints(NumCurvePts).coord(2) = y
    CurvePoints(NumCurvePts).coord(3) = z
    CurvePoints(NumCurvePts).coord(4) = 1
End Sub

' ************************************************
' Create the display polyline.
' ************************************************
Public Sub Extrude()
Dim i As Integer
Dim j As Integer
Dim xoff1 As Single
Dim yoff1 As Single
Dim zoff1 As Single
Dim xoff2 As Single
Dim yoff2 As Single
Dim zoff2 As Single
Dim x1 As Single
Dim y1 As Single
Dim z1 As Single
Dim x2 As Single
Dim y2 As Single
Dim z2 As Single

    Set pline = New ObjPolyline

    ' Create the translated images of the curve.
    For i = 1 To NumPathPts
        ' Calculate offsets for this path point.
        xoff1 = PathPoints(i).coord(1) - PathPoints(1).coord(1)
        yoff1 = PathPoints(i).coord(2) - PathPoints(1).coord(2)
        zoff1 = PathPoints(i).coord(3) - PathPoints(1).coord(3)

        x1 = CurvePoints(1).coord(1) + xoff1
        y1 = CurvePoints(1).coord(2) + yoff1
        z1 = CurvePoints(1).coord(3) + zoff1
        For j = 2 To NumCurvePts
            x2 = CurvePoints(j).coord(1) + xoff1
            y2 = CurvePoints(j).coord(2) + yoff1
            z2 = CurvePoints(j).coord(3) + zoff1
            pline.AddSegment x1, y1, z1, x2, y2, z2
            x1 = x2
            y1 = y2
            z1 = z2
        Next j
    Next i

    ' Create the translated images of the path.
    xoff1 = PathPoints(1).coord(1) - PathPoints(1).coord(1)
    yoff1 = PathPoints(1).coord(2) - PathPoints(1).coord(2)
    zoff1 = PathPoints(1).coord(3) - PathPoints(1).coord(3)
    For i = 2 To NumPathPts
        ' Calculate offsets for this path point.
        xoff2 = PathPoints(i).coord(1) - PathPoints(1).coord(1)
        yoff2 = PathPoints(i).coord(2) - PathPoints(1).coord(2)
        zoff2 = PathPoints(i).coord(3) - PathPoints(1).coord(3)

        For j = 1 To NumCurvePts
            pline.AddSegment _
                CurvePoints(j).coord(1) + xoff1, _
                CurvePoints(j).coord(2) + yoff1, _
                CurvePoints(j).coord(3) + zoff1, _
                CurvePoints(j).coord(1) + xoff2, _
                CurvePoints(j).coord(2) + yoff2, _
                CurvePoints(j).coord(3) + zoff2
        Next j
        xoff1 = xoff2
        yoff1 = yoff2
        zoff1 = zoff2
    Next i
End Sub

' ***********************************************
' Return a string indicating the object type.
' ***********************************************
Property Get ObjectType() As String
    ObjectType = "EXTRUSION"
End Property



' ***********************************************
' Fix the data coordinates at their transformed
' values.
' ***********************************************
Public Sub FixPoints()
Dim i As Integer
Dim j As Integer

    ' Fix the curve points.
    For i = 1 To NumCurvePts
        For j = 1 To 3
            CurvePoints(i).coord(j) = CurvePoints(i).trans(j)
        Next j
    Next i

    ' Fix the path points.
    For i = 1 To NumPathPts
        For j = 1 To 3
            PathPoints(i).coord(j) = PathPoints(i).trans(j)
        Next j
    Next i

    ' Fix the display polyline if it exists.
    If Not pline Is Nothing Then pline.FixPoints
End Sub

' ************************************************
' Apply a transformation matrix which may not
' contain 0, 0, 0, 1 in the last column to the
' object.
' ************************************************
Public Sub ApplyFull(M() As Single)
Dim i As Integer

    ' Transform the curve.
    For i = 1 To NumCurvePts
        m3ApplyFull CurvePoints(i).coord, M, _
                    CurvePoints(i).trans
    Next i

    ' Transform the path.
    For i = 1 To NumPathPts
        m3ApplyFull PathPoints(i).coord, M, _
                    PathPoints(i).trans
    Next i

    ' Transform the display polyline if it exists.
    If Not pline Is Nothing Then pline.ApplyFull M
End Sub

' ************************************************
' Apply a transformation matrix to the object.
' ************************************************
Public Sub Apply(M() As Single)
Dim i As Integer

    ' Transform the curve.
    For i = 1 To NumCurvePts
        m3Apply CurvePoints(i).coord, M, _
                CurvePoints(i).trans
    Next i

    ' Transform the path.
    For i = 1 To NumPathPts
        m3Apply PathPoints(i).coord, M, _
                PathPoints(i).trans
    Next i

    ' Transform the display polyline if it exists.
    If Not pline Is Nothing Then pline.Apply M
End Sub


' ************************************************
' Apply a nonlinear transformation.
' ************************************************
Public Sub Distort(D As Object)
Dim i As Integer

    ' Distort the curve.
    For i = 1 To NumCurvePts
        D.Distort CurvePoints(i).coord(1), _
                  CurvePoints(i).coord(2), _
                  CurvePoints(i).coord(3)
    Next i

    ' Distort the path.
    For i = 1 To NumPathPts
        D.Distort PathPoints(i).coord(1), _
                  PathPoints(i).coord(2), _
                  PathPoints(i).coord(3)
    Next i

    ' Distort the display polyline if it exists.
    If Not pline Is Nothing Then pline.Distort D
End Sub


' ************************************************
' Write the surface's display polyline object to a
' file using Write. The data can later be loaded
' into an ObjPolyline object but not an
' ObjExtrusion object.
' ************************************************
Public Sub FileWritePolyline(filenum As Integer)
    If Not pline Is Nothing Then pline.FileWrite filenum
End Sub


' ************************************************
' Write an extruded surface to a file using Write.
' Begin with "EXTRUSION" to identify this object.
' ************************************************
Public Sub FileWrite(filenum As Integer)
Dim i As Integer

    ' Write basic information.
    Write #filenum, _
        "EXTRUSION", NumCurvePts, NumPathPts

    ' Write the curve points.
    For i = 1 To NumCurvePts
        Write #filenum, _
            CurvePoints(i).coord(1), _
            CurvePoints(i).coord(2), _
            CurvePoints(i).coord(3)
    Next i

    ' Write the path points.
    For i = 1 To NumPathPts
        Write #filenum, _
            PathPoints(i).coord(1), _
            PathPoints(i).coord(2), _
            PathPoints(i).coord(3)
    Next i
End Sub




' ************************************************
' Draw the extrusion on a Form, Printer, or
' PictureBox.
' ************************************************
Public Sub Draw(canvas As Object, Optional R As Variant)
    If Not pline Is Nothing Then _
        pline.Draw canvas, R
End Sub


' ************************************************
' Read a grid from a file using Input.
' Assume the "EXTRUSION" label has already been
' read.
' ************************************************
Public Sub FileInput(filenum As Integer)
Dim i As Integer

    ' Get the basic information.
    Input #filenum, NumCurvePts, NumPathPts

    ' Allocate the curve and path arrays.
    ReDim CurvePoints(1 To NumCurvePts)
    ReDim PathPoints(1 To NumPathPts)

    ' Read the curve points.
    For i = 1 To NumCurvePts
        Input #filenum, _
            CurvePoints(i).coord(1), _
            CurvePoints(i).coord(2), _
            CurvePoints(i).coord(3)
        CurvePoints(i).coord(4) = 1
    Next i

    ' Read the path points.
    For i = 1 To NumPathPts
        Input #filenum, _
            PathPoints(i).coord(1), _
            PathPoints(i).coord(2), _
            PathPoints(i).coord(3)
        PathPoints(i).coord(4) = 1
    Next i

    ' Create the display polyline.
    Extrude
End Sub